;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Object-extensions.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;  this file provides extensions to the set of Object Lisp functions
;;  provided by Pearl Lisp.
;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;ask-funcall
;;
;; ask-funcall is a modified version of ask.
;; it takes as arguments an object, a function, and arguments to the function
;; the arguments are evalÕed in the calling object, and then passed
;; to the function in the called object.
;;
;;  ask-funcall is useful when a function is defined in one object
;;  but the arguments to the function are found in another object
;;
;;for example:
;; 
;;(defobject foo)
;;(ask foo (have 'num 1))
;;(defobject bar)
;;(ask bar (have 'num 2))
;;(defobfun (double bar) (n) (+ n n))
;;(ask foo (double num))   ==>>  error, double not defined
;;(ask bar (double num))  ==>>  error, num not bound
;;(ask foo (ask bar (double num))) ==>> error, num not bound
;;(ask foo (ask-funcall bar double num)) ==>>  2


(defmacro ask-funcall (object symbol &rest args 
                              &aux 
                              gensyms 
                              letlist
                              g)
  (dolist (arg args)
    (setq g (gensym))
    (push g gensyms)
    (push (list g arg) letlist))
  `(let ,(nreverse letlist)
     (ask ,object (,symbol ,@(nreverse gensyms)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;mapc-ask
;;
;;  mapc-ask asks each object in a list to evaluate a set of forms.
;;  It returns the list of objects which it was passed
;;
;;for example
;;
;;(mapc-ask (windows) (print (window-title)) (ed-beep))
;;
;;will ask of the windows to print its title and beep.
;;


(defmacro mapc-ask (objlist-form &rest forms)
  (let ((objects (gensym))
        (obj (gensym)))
  `(let ((,objects ,objlist-form))
        (dolist (,obj ,objects ,objects)
                (ask ,obj ,@forms)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;mapcar-ask
;;
;;  mapcar-ask is the same as mapc-ask except that it returns a list
;;  of the values returned by each ask.
;;
;;for example
;;
;;(mapcar-ask (windows) (window-title))
;;
;;returns a list of the titles of each of the open windows
;;


(defmacro mapcar-ask (objlist-form &rest forms)
  (let ((objects (gensym))
        (results (gensym))
        (obj (gensym)))
  `(let ((,objects ,objlist-form)
         (,results nil))
     (dolist (,obj ,objects (nreverse ,results))
       (push (ask ,obj ,@forms) ,results)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;class-objectp
;;
;;  class-objectp returns t if its argument appears to be set up as
;;  a class.  This will generally be the case if the object was
;;  defined with defobject.
;;
;;  Specifically, the argument must pass the following tests:
;;
;;    the argument is an object
;;    it has an instance variable 'object-name
;;    this instance variable is a symbol
;;    and the symbol is bound globally to the object
;;
;;  If no argument is given, the current object is used.
;;
;;for example
;;
;;(class-objectp *window*)  ===>>  t
;;(defobject foo)
;;(class-objectp foo)   ===>> t
;;(ask foo (class-objectp))   ===>> t
;;(setq bar (kindof))
;;(class-objectp bar)  ===>> nil
;;


(defun class-objectp (&optional (obj (self)))
  (declare (object-variable object-name))
   (if (objectp obj)
       (or (eq obj (ask nil (self)))
           (ask obj (and (ownp 'object-name)
                         (symbolp object-name)
                         (boundp object-name)
                         (eq (symbol-value object-name) obj))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;defclassvars
;;
;;  defclassvars adds a bunch of class variables to an object
;;
;;  its first argument should be a symbol bound to a class-object
;;  the rest should be symbols or lists of the form (symbol value)
;;
;;for example
;;
;;(defclassvars foo (a 10) (b 20) c)
;;(ask foo a)  ===>> 10
;;(ask foo b)  ===>> 20
;;(ask foo c)  ===>> nil
;;


(defmacro defclassvars (objsym &rest var-inits)
  (if (not (symbolp objsym))
    (error "~S is not a symbol bound to a class object." objsym))
  `(define-class-variables ,objsym ',var-inits))

;;define-class-variables is a function used by defclassvars
(defun define-class-variables (object var-init-list)
  (if (not (class-objectp object))
      (report-bad-arg object))
  (let ((sym nil)
        (valform nil))
    (ask object
      (dolist (def var-init-list)
        (setq sym nil)
        (if (atom def)
          (setq sym def valform nil)
          (if (and (consp (cdr def)) (null (cddr def)))
            (setq sym (car def) valform (cadr def))))
        (unless (and sym (symbolp sym))
          (error "Invalid var-init-form in ~S."  var-init-list))
        (have sym (eval valform))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;definstancevars
;;
;;  definstancevars is used to set up a class so that it always gives
;;  certain instance variables to its instances.
;;
;;  the first argument to definstancevars should be a symbol bound to a
;;  class-object the rest should be symbols or lists of the form (symbol value).
;;
;;definstancevars depends on the definition of exist given below.
;;
;;for example
;;
;;(defobject foo)
;;(defclassvars foo (a 1) (b 2))
;;(definstancevars foo (ia 10) ib)
;;(setq bar (oneof foo))
;;(setq quux (oneof foo))
;;(ask bar a)   ==>> 1
;;(ask quux a)  ==>> 1
;;(ask bar (setq a 2))
;;(ask quux a)  ==>>  2 defined with defclassvars, so common to all instances
;;(ask bar ia)  ==>>  10
;;(ask quux ia)  ==>>  10
;;(ask bar (setq ia 20))
;;(ask quux ia)  ==>> 10 defined with defclassvars, so each has its own

(defmacro definstancevars (objsym &rest var-inits)
  (unless (and (symbolp objsym)
               (boundp objsym)
               (class-objectp (symbol-value objsym)))
    (error "~S is not a symbol bound to a class object." objsym))
  `(define-instance-vars ',objsym ',var-inits))

;;this function is used by definstancevars
(defun define-instance-vars (objsym var-init-list)
  (let ((normalized-defs nil)
        (sym nil)
        (valform nil))
    (dolist (def var-init-list)
      (setq sym nil)
      (if (atom def)
        (setq sym def valform nil)
        (if (and (consp (cdr def)) (null (cddr def)))
          (setq sym (car def) valform (cadr def))))
      (unless (and sym (symbolp sym))
        (error "Invalid var-init-form in ~S."  var-init-list))
      (push (list sym valform) normalized-defs))
    (ask (symbol-value objsym) (have '%iv-defs (nreverse normalized-defs)))))


;;this version of exist supporst definstancevars
(defobfun exist (args)
  (declare (ignore args) (object-variable %iv-defs))
  (dolist (obj (object-ancestors (self)))
    (when (ask obj (ownp '%iv-defs))
      (let ((ivdefs (ask obj %iv-defs)))
        (dolist (ivdef ivdefs)
          (let ((sym (car ivdef)))
            (unless (ownp sym)                
              (have sym (eval (cadr ivdef)))))))))
  nil)

(provide 'object-extensions)